home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / DDJMAG / DDJ8607.ZIP / WINDOW4.JUL < prev   
Text File  |  1986-07-31  |  21KB  |  1,002 lines
  1. file: WINDOW.BLK       Block: 0   
  2.                                                      cl 11/10/85
  3.  
  4.  
  5. window program 
  6. by
  7. Craig A. Lindley
  8. Manitou Springs
  9. Colorado                                                        
  10. November 1985
  11.  
  12.  
  13. file: WINDOW.BLK       Block: 1   
  14.  
  15.  
  16. \ window routines                                    cl 11/10/85
  17.  
  18. \ window load screen
  19.  
  20.  
  21. warning off
  22.  
  23.  
  24. dark
  25.  
  26. .( Compiling window package and demo program )
  27.  
  28. cr
  29.  
  30.  
  31. 2 32 thru
  32.                                                                 
  33.  
  34. warning on
  35.  
  36.                                                                 
  37.  
  38. file: WINDOW.BLK       Block: 2   
  39.  
  40.  
  41.  
  42. \ case statement                                     cl 11/10/85
  43.  
  44. \ Dr. Charles Eakers Forth Dimensions Vol 2, Num 3
  45.  
  46. : ?comp   state @ not abort" Compilation only" ;
  47.  
  48. : ?pairs  <>         abort" Bad CASE statement"  ;
  49.  
  50.                                                                 
  51.  
  52. : case    ?comp csp @ !csp 4 ; immediate
  53.  
  54. : of      4 ?pairs
  55.  
  56.           compile over compile = compile ?branch
  57.  
  58.           here 0 , compile drop 5 ; immediate
  59.  
  60. : endof   5 ?pairs compile branch here 0 ,
  61.  
  62.           swap   >resolve 4 ; immediate
  63.  
  64. : endcase 4 ?pairs compile drop
  65.  
  66.           begin sp@ csp @ <>
  67.  
  68.           while >resolve repeat
  69.  
  70.           csp ! ; immediate
  71.  
  72.  
  73.                                                                 
  74.  
  75. file: WINDOW.BLK       Block: 3   
  76.  
  77.  
  78.  
  79. \ window routines                                    cl 11/10/85
  80.  
  81. \ write count # of chars with attrib at cursor position
  82.  
  83. code chra                       \ char/attrib count --
  84.  
  85.  cx pop ax pop ah bl mov        \ get count in cx, attrib in bl
  86.  
  87.  bh bh xor 9 # ah mov           \ char in al, func. code in ah
  88.  
  89.  si push 16 int si pop          \ do video interrupt
  90.  
  91.  next                                                           
  92.  
  93. end-code
  94.  
  95. \ write 1 char with attrib at cursor - update cursor position
  96.  
  97. code chra+                      \ char/attrib --
  98.  
  99.  ax pop ah bl mov bh bh xor     \ char in al, attrib in bl
  100.  
  101.  1 # cx mov 9 # ah mov          \ char in al, func. code in ah
  102.  
  103.  si push 16 int                 \ count=1, write char/attrib
  104.  
  105.  3 # ah mov 16 int dl inc 2 # ah mov 16 int
  106.  
  107.  si pop next                    \ inc cursor position
  108.  
  109. end-code
  110.  
  111.  
  112.  
  113.  
  114. file: WINDOW.BLK       Block: 4   
  115.  
  116.  
  117.  
  118. \ window routines                                    cl 11/10/85
  119.  
  120. \ read char and attrib at cursor position
  121.  
  122. code rdchra                     \ -- char/attrib
  123.  
  124.  0 # bh mov 8 # ah mov          \ pg =0  func. code = 8
  125.  
  126.  si push 16 int si pop          \ do video interrupt
  127.  
  128.  1push                          \ char/attrib to stk
  129.  
  130. end-code
  131.  
  132.                                                                 
  133.  
  134. \ put char with attrib at x,y
  135.  
  136. : putch                         \ x y char/attrib --
  137.  
  138.   >r at r> 1 chra ;
  139.  
  140.                                                                 
  141.  
  142. \ get char with attrib at x,y
  143.  
  144. : getch                         \ x y -- char/attrib
  145.  
  146.   at rdchra ;
  147.  
  148.  
  149.  
  150.                                                                 
  151.  
  152. file: WINDOW.BLK       Block: 5   
  153.  
  154.  
  155.  
  156. \ window routines                                    cl 11/10/85
  157.  
  158.  
  159.  
  160. \ draw count # of chars/attrib starting at x,y
  161.  
  162. : draw_row                      \ x y char/attrib count --
  163.  
  164.   >r >r at r> r> chra ;
  165.  
  166.                                                                 
  167.  
  168. \ scroll specified window up n lines
  169.  
  170. code scrlup                     \ xul yul xlr ylr cnt attrib --
  171.  
  172.  bx pop bl bh mov di pop        \ bh attrib si # of lines
  173.  
  174.  dx pop dl dh mov ax pop al dl mov \ dx has lr x y
  175.  
  176.  cx pop cl ch mov ax pop al cl mov \ cx has ul x y
  177.  
  178.  di ax mov si push bp push      \ save regs
  179.  
  180.  6 # ah mov 16 int              \ ax # of lines func. code ah
  181.  
  182.  bp pop si pop next             \ restore forth's regs
  183.  
  184. end-code
  185.  
  186.  
  187.  
  188. file: WINDOW.BLK       Block: 6   
  189.  
  190. \ window routines                                    cl 11/10/85
  191.  
  192. \ memory management support
  193.  
  194. \ tell DOS to allociate memory bytes
  195.  
  196. code calloc                     \ # bytes -- seg T
  197.  
  198.  bx pop 4 # cl mov bx cl shr    \         -- maxp error code F
  199.  
  200.  bx inc 72 # ah mov 33 int      \ int 21h func. code 48h
  201.  
  202.  u< if   bx push ax push ax ax xor \ if C then error
  203.  
  204.     else ax push -1 # ax mov then 1push
  205.  
  206. end-code
  207.  
  208. \ tell DOS to free memory segment
  209.  
  210. code free                       \ seg -- T
  211.  
  212.  ax pop ax es mov               \     -- error code F
  213.  
  214.  73 # ah mov 33 int             \ int 21h func. code 49h
  215.  
  216.  u< if   ax push ax ax xor      \ if C then error
  217.  
  218.     else -1 # ax mov then 1push
  219.  
  220. end-code
  221.  
  222.  
  223. file: WINDOW.BLK       Block: 7   
  224.  
  225. \ window routines                                    cl 11/10/85
  226.  
  227. \ memory management support
  228.  
  229. \ tell DOS to shrink or expand allociated memory segment
  230.  
  231.  
  232.  
  233. code setblock                   \ # bytes -- T
  234.  
  235.  cs ax mov ax es mov            \         -- maxp error code F
  236.  
  237.  bx pop 4 # cl mov bx cl shr    \ bx has # of paragraphs
  238.  
  239.  bx inc 74 # ah mov 33 int      \ int 21h func. code 4Ah
  240.  
  241.  u< if   bx push ax push ax ax xor \ if C then error
  242.  
  243.     else -1 # ax mov
  244.  
  245.     then 1push
  246.  
  247. end-code
  248.  
  249.  
  250. file: WINDOW.BLK       Block: 8   
  251.  
  252. \ window routines                                    cl 11/10/85
  253.  
  254. \ extended word fetch and store words
  255.  
  256. \ fetch word from extended memory
  257.  
  258. code e@                         \ seg addr -- n
  259.  
  260.  bx pop es pop                  \ seg in es addr in bx
  261.  
  262.  es: 0 [bx] ax mov              \ get the data on stk
  263.  
  264.  1push
  265.  
  266. end-code
  267.  
  268.  
  269. \ store word in extended memory
  270.  
  271. code e!                         \ n seg addr --
  272.  
  273.  bx pop es pop ax pop
  274.  
  275.  ax es: 0 [bx] mov              \ store the data
  276.  
  277.  next
  278.  
  279. end-code
  280.  
  281.  
  282.  
  283. file: WINDOW.BLK       Block: 9   
  284.  
  285. \ window routines                                    cl 11/10/85
  286.  
  287. \ read current cursor location
  288.  
  289. code rdcur                      \ -- x y
  290.  
  291.  si push 0 # bh mov 3 # ah mov  \ int 10h func. code 3
  292.  
  293.  16 int  si pop ah ah xor
  294.  
  295.  dl al mov ax push dh al mov
  296.  
  297.  1push
  298.  
  299. end-code                                                                
  300.  
  301.  
  302.  
  303. file: WINDOW.BLK       Block: 10  
  304.  
  305. \ window routines                                    cl 11/10/85
  306.  
  307. \ window control block (wcb) record layout
  308.  
  309.  0 constant ulx     2 constant uly       \ upper left corner
  310.  
  311.  4 constant width   6 constant height    \ width and height
  312.  
  313.  8 constant curx   10 constant cury      \ current cursor pos
  314.  
  315. 12 constant oldx   14 constant oldy      \ old cursor pos.
  316.  
  317. 16 constant bufseg 18 constant oldwcbseg \ seg storage
  318.  
  319. 20 constant attrib                       \ window attrib.
  320.  
  321. 22 constant record_size                  \ size of record
  322.  
  323. 15 constant boarder                      \ boarder attribute
  324.  
  325. hex
  326.  
  327. b800 constant v_seg                      \ video memory start
  328.  
  329.    variable wcbseg                       \ current wcb seg
  330.  
  331. decimal                                  \ storage              
  332.  
  333.  
  334.  
  335.  
  336. file: WINDOW.BLK       Block: 11  
  337.  
  338. \ window routines                                    cl 11/10/85
  339.  
  340. \ extended memory fetch and store words
  341.  
  342. \ store word n at addr in current wcb
  343.  
  344. : wcbseg!                       \ n addr --
  345.  
  346.   wcbseg @ swap e! ;            \ store at addr in wcb seg
  347.  
  348.  
  349. \ fetch word from addr in current wcb
  350.  
  351. : wcbseg@                       \ addr -- n
  352.  
  353.   wcbseg @ swap e@ ;            \ fetch from addr in wcb seg
  354.  
  355.  
  356. file: WINDOW.BLK       Block: 12  
  357.  
  358. \ window routines                                    cl 11/10/85
  359.  
  360. \ window frame drawing routines
  361.  
  362. : top
  363.  
  364.   ulx wcbseg@ uly wcbseg@ [ 201 boarder 256 * + ] literal putch
  365.  
  366.   ulx wcbseg@ 1+ uly wcbseg@ [ 205 boarder 256 * + ] literal
  367.  
  368.   width wcbseg@ draw_row
  369.  
  370.   ulx wcbseg@ width wcbseg@ + 1+ uly wcbseg@
  371.  
  372.   [ 187 boarder 256 * + ] literal putch ;
  373.  
  374. : bottom
  375.  
  376.   ulx wcbseg@ uly wcbseg@ height wcbseg@ + 1+
  377.  
  378.   [ 200 boarder 256 * + ] literal putch
  379.  
  380.   ulx wcbseg@ 1+ uly wcbseg@ height wcbseg@ + 1+
  381.  
  382.   [ 205 boarder 256 * + ] literal width wcbseg@ draw_row
  383.  
  384.   ulx wcbseg@ width wcbseg@ + 1+ uly wcbseg@ height wcbseg@ + 1+ 
  385.  
  386.   [ 188 boarder 256 * + ] literal putch ;
  387.  
  388.  
  389.  
  390. file: WINDOW.BLK       Block: 13  
  391.  
  392. \ window routines                                    cl 11/10/85
  393.  
  394. \ window frame drawing routines
  395.  
  396. : sides
  397.  
  398.   uly wcbseg@ height wcbseg@ + 1+ uly wcbseg@ 1+
  399.  
  400.   do ulx wcbseg@ i [ 186 boarder 256 * + ] literal putch
  401.  
  402.      ulx wcbseg@ width wcbseg@ + 1+ i
  403.  
  404.      [ 186 boarder 256 * + ] literal putch
  405.  
  406.   loop ; 
  407.  
  408. file: WINDOW.BLK       Block: 14  
  409.  
  410. \ window routines                                    cl 11/10/85
  411.  
  412. \ temporary data storage areas
  413.  
  414. \ used by scn->buf and buf->scn
  415.  
  416.  
  417. label save_h   nop nop          \ storage for height parameter
  418.  
  419. label save_w   nop nop          \ storage for width  parameter
  420.  
  421. label save_ptr nop nop          \ storage for start pointer
  422.  
  423. label save_si  nop nop          \ storage for forths IP reg
  424.  
  425. label save_ds  nop nop          \ storage for current ds reg
  426.  
  427.  
  428. file: WINDOW.BLK       Block: 15  
  429.  
  430. \ window routines                                    cl 11/10/85
  431.  
  432. \ move data from screen to memory buffer
  433.  
  434. hex
  435.  
  436. code scn->buf                   \ x y width height seg --
  437.  
  438.  cld es pop 0 # di mov save_h #) pop  save_w #) pop ax pop
  439.  
  440.  a0 # bl mov bl mul bx pop bx shl bx ax add ax save_ptr #) mov
  441.  
  442.  si save_si #) mov ds ax mov ax save_ds #) mov v_seg # ax mov
  443.  
  444.  ax ds mov cs: save_ptr #) si mov cs: save_h #) cx mov
  445.  
  446.  here cx push cs: save_w #) cx mov  rep movs
  447.  
  448.       cs: save_ptr #) si mov a0 # si add si cs: save_ptr #) mov
  449.  
  450.       cx pop
  451.  
  452.  loop
  453.  
  454.  cs: save_ds #) ax mov  ax ds mov
  455.  
  456.  save_si #) si mov
  457.  
  458.  next
  459.  
  460. end-code
  461.  
  462.  
  463. file: WINDOW.BLK       Block: 16  
  464.  
  465. \ window routines                                    cl 11/10/85
  466.  
  467. \ move data from memory buffer to screen
  468.  
  469. code buf->scn                   \ seg x y width height --
  470.  
  471.  cld  save_h #) pop  save_w #) pop ax pop  a0 # bl mov
  472.  
  473.  bl mul bx pop bx shl bx ax add ax save_ptr #) mov
  474.  
  475.  si save_si #) mov ds ax mov ax save_ds #) mov ax pop ax ds mov
  476.  
  477.  v_seg # ax mov ax es mov 0 # si mov cs: save_ptr #) di mov
  478.  
  479.  cs: save_h #) cx mov
  480.  
  481.  here cx push cs: save_w #) cx mov  rep movs
  482.  
  483.       cs: save_ptr #) di mov a0 # di add di cs: save_ptr #) mov
  484.  
  485.       cx pop
  486.  
  487.  loop
  488.  
  489.  cs: save_ds #) ax mov  ax ds mov   save_si #) si mov
  490.  
  491.  next
  492.  
  493. end-code
  494.  
  495. decimal
  496.  
  497.  
  498.  
  499. file: WINDOW.BLK       Block: 17  
  500.  
  501. \ window routines                                    cl 11/10/85
  502.  
  503. \ lowest level window routine
  504.  
  505. \ moves screen data to memory buffer
  506.  
  507. \ and then draws the actual window frame
  508.  
  509. : ((window))                    \ move data scn->buf
  510.  
  511.   ulx wcbseg@ uly wcbseg@       \ x y coordinates
  512.  
  513.   width wcbseg@ 2+ height wcbseg@ 2+ \ width height
  514.  
  515.   bufseg wcbseg@ scn->buf       \ get buf seg addr
  516.  
  517.   top sides bottom ;
  518.  
  519.  
  520.  
  521. file: WINDOW.BLK       Block: 18  
  522.  
  523. \ window routines                                    cl 11/10/85
  524.  
  525. \ clear window routine
  526.  
  527. : clr_window                    \ --
  528.  
  529.   ulx wcbseg@ 1+                \ upper left  corner x
  530.  
  531.   uly wcbseg@ 1+                \ upper right corner y
  532.  
  533.   ulx wcbseg@ width wcbseg@ +   \ lower left  corner x
  534.  
  535.   uly wcbseg@ height wcbseg@ +  \ lower right corner y
  536.  
  537.   0 attrib wcbseg@ scrlup       \ scroll entire window
  538.  
  539.   0 curx wcbseg!                \ home window cursor
  540.  
  541.   0 cury wcbseg! ;                                              
  542.  
  543.  
  544.  
  545.  
  546. file: WINDOW.BLK       Block: 19  
  547.  
  548. \ window routines                                    cl 11/10/85
  549.  
  550. : (window)                      \ x y width height attrib -- f
  551.  
  552.   record_size calloc            \ try to allociate space for wcb 
  553.  
  554.   if wcbseg @ >r wcbseg ! r>    \ if successful store seg var
  555.  
  556.      oldwcbseg wcbseg! attrib wcbseg!   \ save attrib in wcb
  557.  
  558.      2dup 2+ swap 2+ * 2* calloc \ alloc space for screen buf
  559.  
  560.      if bufseg wcbseg!           \ save buffer seg
  561.  
  562.         height wcbseg! width wcbseg!    \ save parameters in
  563.  
  564.         uly    wcbseg! ulx   wcbseg!    \ new wcb
  565.  
  566.         rdcur oldy wcbseg! oldx wcbseg! \ get old cursor pos.
  567.  
  568.         ((window)) clr_window true      \ move data draw frame
  569.  
  570.      else ." buffer alloc. failure" cr  \ if no memory
  571.  
  572.        wcbseg @ free drop drop 0 \ free wcb memory
  573.  
  574.      then
  575.  
  576.   else ." wcb alloc. failure" drop drop 0
  577.  
  578.   then ;                                \ return flag
  579.  
  580.  
  581.  
  582. file: WINDOW.BLK       Block: 20  
  583.  
  584. \ window routines                                    cl 11/10/85
  585.  
  586. \ window parameter checking
  587.  
  588. : wfit cr
  589.  
  590.   abort" Window won't fit on crt" ;
  591.  
  592. : open_window                   \ x y width height attrib -- f
  593.  
  594.   depth 5 >=
  595.  
  596.    if >r 4dup rot + 2+ 24 <=
  597.  
  598.      if + 2+ 79 <=
  599.  
  600.        if r> (window)
  601.  
  602.        else cr ." ULX and/or WIDTH incorrect" wfit
  603.  
  604.        then
  605.  
  606.      else   cr ." ULY and/or HEIGHT incorrect" wfit
  607.  
  608.      then
  609.  
  610.    else cr ." Incorrect # of parameters specified" quit
  611.  
  612.    then ;
  613.  
  614.  
  615.  
  616. file: WINDOW.BLK       Block: 21  
  617.  
  618. \ window routines                                    cl 11/10/85
  619.  
  620. \ close the current window (defined by wcbseg data)
  621.  
  622. \ free wcb and buffer memory then unlink window
  623.  
  624. : close_window                  \ --
  625.  
  626.   wcbseg @ 0 <>                 \ if window exists
  627.  
  628.   if bufseg wcbseg@             \ get buffer seg addr
  629.  
  630.      ulx wcbseg@ uly wcbseg@    \ get x,y corner
  631.  
  632.      width wcbseg@ 2+ height wcbseg@ 2+
  633.  
  634.      buf->scn                   \ mov data back to screen
  635.  
  636.      oldx wcbseg@ oldy wcbseg@ at
  637.  
  638.      bufseg wcbseg@ free drop   \ free buffer seg memory
  639.  
  640.      wcbseg @ free drop         \ free wcb seg memory
  641.  
  642.      oldwcbseg wcbseg@ wcbseg ! \ unlink this window
  643.  
  644.   else                          \ if no current window
  645.  
  646.      cr ." No open windows !" cr
  647.  
  648.   then ;
  649.  
  650.  
  651.  
  652.  
  653. file: WINDOW.BLK       Block: 22  
  654.  
  655. \ window routines                                    cl 11/10/85
  656.  
  657. \ position cursor in window
  658.  
  659. \ if parameters out of range do the best we can and still
  660.  
  661. \ stay in the window
  662.  
  663. : wat                            \ x y --
  664.  
  665.   swap dup abs width wcbseg@     \ req. x in window ?
  666.  
  667.   1- >                           \ if not then
  668.  
  669.   if drop width wcbseg@ 1- then  \ set x to max in window
  670.  
  671.   curx wcbseg!                   \ save new cursor x position
  672.  
  673.   dup abs height wcbseg@         \ req y in window ?
  674.  
  675.   1- >                           \ if not then
  676.  
  677.   if drop height wcbseg@ 1- then \ set y to max in window
  678.  
  679.   cury wcbseg!                   \ save new cursor y position
  680.  
  681.   curx wcbseg@ ulx wcbseg@ + 1+  \ actual cursor position
  682.  
  683.   cury wcbseg@ uly wcbseg@ + 1+  \ calculation
  684.  
  685.   at ;
  686.  
  687.  
  688.  
  689. file: WINDOW.BLK       Block: 23  
  690.  
  691. \ window routines                                    cl 11/10/85
  692.  
  693. \ read window cursor position
  694.  
  695. : rdwcur                        \ -- x y
  696.  
  697.   curx wcbseg@ cury wcbseg@ ;
  698.  
  699. \ read char/attrib of character at cursor in window
  700.  
  701. : rdwcha                        \ x y -- char/attrib
  702.  
  703.   wat rdchra ;
  704.  
  705. \ scroll window up for blank line at bottom
  706.  
  707. : scroll_window                 \ --
  708.  
  709.   ulx wcbseg@ 1+ uly wcbseg@ 1+ \ upper left corner to scroll
  710.  
  711.   ulx wcbseg@  width wcbseg@ +  \ lower right x coordinate
  712.  
  713.   uly wcbseg@ height wcbseg@ +  \ lower right y coordinate
  714.  
  715.   1 attrib wcbseg@ scrlup ;     \ up 1 line
  716.  
  717.  
  718.  
  719.  
  720. file: WINDOW.BLK       Block: 24 
  721.  
  722. \ window routines                                    cl 11/10/85
  723.  
  724. \ do carrage return in the current window
  725.  
  726. : crout rdwcur nip 0 swap wat ; \ carrage ret in window
  727.  
  728. \ do a line feed in the current window
  729.  
  730. : lfout rdwcur 1+ dup
  731.  
  732.   height wcbseg@ 1- >           \ cursor out of window
  733.  
  734.   if 1- scroll_window then      \ if so scroll the window up
  735.  
  736.   wat ;                         \ place the cursor in window
  737.  
  738.  
  739. \ do a back space in the current window
  740.  
  741. : bsout rdwcur over 0<>         \ backspace cursor in window
  742.  
  743.   if swap 1- swap wat then ;
  744.  
  745.  
  746. \ ring the bell
  747.  
  748. : bell 7 (emit) ;               \ sound the horn
  749.  
  750.  
  751.  
  752.  
  753. file: WINDOW.BLK       Block: 25  
  754.  
  755. \ window routines                                    cl 11/10/85
  756.  
  757. : wemit dup 32 <                \ char --
  758.  
  759.   if case                       \ if control char process it
  760.  
  761.        7 of bell  endof         \ if bell then
  762.  
  763.        8 of bsout endof         \ if backspace then
  764.  
  765.       10 of lfout endof         \ if linefeed then
  766.  
  767.       13 of crout endof         \ if carrage ret then
  768.  
  769.      endcase
  770.  
  771.   else                          \ else its a display char
  772.  
  773.      attrib wcbseg@ 256 * +     \ char now char/attrib
  774.  
  775.      rdwcur rot chra+           \ output char adv. cursor
  776.  
  777.      drop dup width wcbseg@ 1- =   \ if at end of window line
  778.  
  779.      if drop lfout crout        \ do lfcr to next line
  780.  
  781.      else 1+ curx wcbseg!       \ store new x coordinate
  782.  
  783.      then
  784.  
  785.   then ;
  786.  
  787.  
  788.  
  789. file: WINDOW.BLK       Block: 26  
  790.  
  791. \ window routines                                    cl 11/10/85
  792.  
  793. : wcr 13 wemit 10 wemit ;       \ window carrage return
  794.  
  795.  
  796.  
  797. : wtype 0                       \ window equiv. of type
  798.  
  799.   ?do count wemit loop drop ;
  800.  
  801. \ use memory manager to give forth a full 64k segment
  802.  
  803. : initialize                    \ --
  804.  
  805.   cr ." Memory management "     \ output 1/2 msg
  806.  
  807.   -1 setblock                   \ request FFFF bytes
  808.  
  809.   if                            \ if successful
  810.  
  811.     ." initialized"             \ output message and
  812.  
  813.     0 wcbseg !                  \ initialize link variable
  814.  
  815.   else
  816.  
  817.     ." error" quit              \ abort program
  818.  
  819.   then cr ;
  820.  
  821.  
  822.  
  823.  
  824. file: WINDOW.BLK       Block: 27  
  825.  
  826. \ window demo                                        cl 11/10/85
  827.  
  828. \ window equivalents of standard Forth words
  829.  
  830. : wlist block 16 0
  831.  
  832.   do dup i c/l * + c/l          \ window equiv. of list
  833.  
  834.      -trailing wtype wcr
  835.  
  836.   loop drop ;
  837.  
  838. : wtriad 3 / 3 * 3 bounds       \ window equiv. of triad
  839.  
  840.   do i wlist                    \ list screen in window
  841.  
  842.      wcr wcr                    \ add a couple of cr's
  843.  
  844.   loop ;
  845.  
  846.  
  847.  
  848. file: WINDOW.BLK       Block: 28  
  849.  
  850. \ window demo                                        cl 11/10/85
  851.  
  852. \ window canned messages
  853.  
  854. : msg1
  855.  
  856.   " This could be your application program! " wtype ;
  857.  
  858. : msg2 " Ain't this window package something! " wtype ;
  859.  
  860. : msg3 "  ** Window 4 ** " wtype ;
  861.  
  862.  
  863. : msg1out 0 0 wat               \ output msg1 20 times
  864.  
  865.   20 0 do msg1 loop ;
  866.  
  867.  
  868. : msg2out 0 0 wat               \ output msg2 10 times
  869.  
  870.   10 0 do msg2 loop ;
  871.  
  872.  
  873. : msg3out 0 0 wat               \ output msg3 80 times
  874.  
  875.   80 0 do msg3 loop ;
  876.  
  877.  
  878.  
  879.  
  880. file: WINDOW.BLK       Block: 29  
  881.  
  882. \ window demo                                        cl 11/10/85
  883.  
  884. \ video attribute constants
  885.  
  886. 7   constant normal         15 constant high_int
  887.  
  888. 112 constant reverse       128 constant blink
  889.  
  890.  
  891. : fill_crt 0 0                  \ fill crt with rev video A's
  892.  
  893.   [ ascii A reverse 256 * + ]   \ calculate char/attrib code
  894.  
  895.   literal 2048 draw_row ;
  896.  
  897.  
  898. : wait 10000 0 do noop loop ;   \ timing loop
  899.  
  900.  
  901.  
  902.  
  903. file: WINDOW.BLK       Block: 30  
  904.  
  905. \ window demo                                        cl 11/10/85
  906.  
  907. \ define the four windows used in the demo program
  908.  
  909.  
  910. : window1                       \ define window #1
  911.  
  912.   0 0 20 10 reverse open_window ;
  913.  
  914.  
  915. : window2                       \ define window #2
  916.  
  917.   2 1 70 8 normal open_window ;
  918.  
  919.  
  920. : window3                       \ define window #3
  921.  
  922.   7 6 69 10 reverse open_window ;
  923.  
  924.  
  925. : window4                       \ define window #4
  926.  
  927.   10 9 59 4 high_int open_window ;
  928.  
  929.  
  930.  
  931.  
  932. file: WINDOW.BLK       Block: 31  
  933.  
  934. \ window demo                                        cl 11/10/85
  935.  
  936. : demo
  937.  
  938.   fill_crt window1
  939.  
  940.   if 0 0 wat msg2 wait wcr wait 7 emit wcr
  941.  
  942.      wait " It sure is" wtype wait 8 wemit 8 wemit
  943.  
  944.      wait 10 5 wat wait window2
  945.  
  946.      if msg1out wait window3
  947.  
  948.         if 0 10 wat 24 wtriad wait window4
  949.  
  950.            if msg3out wait close_window wait close_window
  951.  
  952.               wait clr_window msg2out wait close_window
  953.  
  954.               0 wlist wait wait wait wait close_window
  955.  
  956.            then
  957.  
  958.         then
  959.  
  960.      then
  961.  
  962.   then
  963.  
  964.   wait ;
  965.  
  966.  
  967.  
  968.  
  969. file: WINDOW.BLK       Block: 32  
  970.  
  971. \ window demo                                        cl 11/10/85
  972.  
  973. only forth also dos also        \ search dos and forth
  974.  
  975. : test empty-buffers            \ dummy program name
  976.  
  977.   initialize                    \ initialize memory manager
  978.  
  979.   " window.blk"  fcb1 (!fcb)    \ parse filename to fcb
  980.  
  981.   fcb1 !files open-file         \ open the file to list
  982.  
  983.   2 0
  984.  
  985.   do                            \ run the demo 2 times
  986.  
  987.     demo wait wait wait dark wait
  988.  
  989.   loop
  990.  
  991.   ." What did you think of that Huh?" cr bye ;
  992.  
  993.  
  994. only forth also                 \ power up search order
  995.  
  996. ' test is boot                  \ make demo run automatically
  997.  
  998. save-system window.com          \ create .COM demo
  999.  
  1000.  
  1001.                         \End Listing
  1002.